perm filename ELIP.F4[SAB,LCS] blob
sn#349448 filedate 1978-04-16 generic text, type C, neo UTF8
COMMENT ā VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 DIMENSION IBUF(5000)
C00004 ENDMK
Cā;
DIMENSION IBUF(5000)
COMMON /FAC/JFAC,KFAC
IF(JFAC.EQ.0)JFAC=100
IF(KFAC.EQ.0)KFAC=100
CALL PLOTS(IBUF,5000,1)
CALL PLOT( 4., 2. ,-3)
A=0
B=0
DO 2 K=1,2
CC1 CALL ELLIPS(4.,2.,45.)
1 CALL ELLIP2(4.,2.,A,B,45.)
A=0
2 B=-10
CALL PLOT(0.,-30.,-3)
CALL PLOT(0.,0.,999)
STOP
END
SUBROUTINE ELLIP2(A,B,XC,YC,PSI)
N=IFIX(A*50.)+12
IF(B.GT.A)N=IFIX(B*50.)+12
PHI= (6.2831853/360.)*PSI
X=A
Y=0.0
THETA=6.2831853/FLOAT(N)
C1=COS(THETA)
C4=A/B
C6=SIN(THETA)
C2=C6*C4
C3=C6/C4
C=COS(PHI)
S=SIN(PHI)
CALL PLOT(A*C+XC,A*S+YC,3)
DO 10 I=1,N
U=X*C1-Y*C2
V=X*C3+Y*C1
X=U
Y=V
X1=X*C-Y*S
Y1=X*S+Y*C
CALL PLOT(X1+XC,Y1+YC,2)
10 CONTINUE
RETURN
END